home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / _tile / f83 / queues < prev    next >
Encoding:
Text File  |  1991-08-15  |  4.3 KB  |  134 lines
  1. \
  2. \  DOUBLE LINKED LISTS
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 23 July 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, structures, blocks
  20. \
  21. \  Description:
  22. \       Allows definition and basic manipulation of queue data structures.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. #include <Tile$Lib>.structures
  40. #include <Tile$Lib>.blocks
  41.  
  42. blocks structures queues definitions
  43.  
  44. struct.type QUEUE ( -- )
  45.   ptr +succ ( queue -- addr) private
  46.   ptr +pred ( queue -- addr) private
  47. struct.init ( queue -- )
  48.   dup over +succ ! dup +pred !
  49. struct.end 
  50.  
  51. : succ ( queue -- succ)
  52.   +succ @
  53. ;
  54.  
  55. : pred ( queue -- pred)
  56.   +pred @
  57. ;
  58.  
  59. #ifundef ?empty-queue  ( Check if the kernel supports queues)
  60.  
  61. : ?empty-queue ( queue -- bool)
  62.   dup +succ @ =                        ( Pointer to itself)
  63. ;
  64.  
  65. : enqueue ( item queue -- )
  66.   2dup +pred @ swap +pred !            ( item.pred = queue.pred)
  67.   2dup swap +succ !                    ( item.succ = queue)
  68.   2dup +pred @ +succ !                 ( queue.pred.succ = item)
  69.   +pred !                              ( queue.pred = item)
  70. ;
  71.  
  72. : dequeue ( item -- )
  73.   dup +succ @ over +pred @ +succ !     ( item.pred.succ = item.succ)
  74.   dup +pred @ over +succ @ +pred !     ( item.succ.pred = item.pred)
  75.   dup over +succ !                     ( item.succ = item)
  76.   dup +pred !                          ( item.pred = item)
  77. ;
  78.  
  79. #then
  80.  
  81. : size-queue ( queue -- num)
  82.   0 swap dup >r                                ( Save pointer to queue header)
  83.   begin
  84.     swap 1+ swap +succ @               ( Increment size and step to next)
  85.     dup r@ =                           ( Is this the last element?)
  86.   until
  87.   r> 2drop                             ( Drop parameters and return size)
  88. ;
  89.  
  90. : map-queue ( queue block[item -- ] -- )
  91.   over >r                              ( Save pointer to queue header)
  92.   begin
  93.     over +succ @ >r                    ( Save pointer to next item)
  94.     dup >r                             ( Save block on return stack)
  95.     call                               ( Call the block with the item)
  96.     2r> tuck                           ( Restore the parameters)
  97.     r@ =                               ( Check if end of queue)
  98.   until
  99.   r> drop 2drop                        ( Drop all temporary parameters)
  100. ;
  101.  
  102. : ?map-queue ( queue block[item -- bool] -- )
  103.   over >r                              ( Save pointer to queue header)
  104.   begin
  105.     over +succ @ >r                    ( Save pointer to next item)
  106.     dup >r                             ( Save block on return stack)
  107.     call                               ( Call the block with the item)
  108.     if 2r> true                                ( Exit the iteration)
  109.     else
  110.       2r> tuck                         ( Restore the parameters)
  111.       r@ =                             ( Check if end of queue)
  112.     then
  113.   until
  114.   r> drop 2drop                        ( Drop all temporary parameters)
  115. ;
  116.  
  117. : ?member-queue ( element queue -- bool)
  118.   dup >r                               ( Save pointer to queue header)
  119.   begin
  120.     2dup =                             ( Is this the element?)
  121.     if 2drop r> drop true exit then    ( Well drop the parameters and return)
  122.     +succ @ dup r@ =                   ( Step to the next. Last element?)
  123.   until
  124.   r> drop 2drop false
  125. ;
  126.  
  127. : .queue ( queue -- )
  128.   ." queue#" dup .                     ( Print address of queue)
  129.   ." succ: " dup +succ @ .             ( Print successor)
  130.   ." pred: " +pred @ .                 ( Print predecessor)
  131. ;
  132.  
  133. forth only
  134.